CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/swagd_f.zip/FINDREPL.SWG/0010_NICECODE.PAS.pas

Pascal/Delphi Source File | 1993-05-28 | 15KB | 428 lines

(*
>Does anyone know of a utility Program that will apply some sort of
>reasonable structuring to a pascal source File?

I'm not sure if it's what you want, but the source For a Pascal
reFormatter, etc, was entered in the Fidonet PASCAL Programming
Competition, and came third (I came second!!).

As you can see by the File dates, this is a very recent thing and
since it is Nearly too late I toyed With the idea of just keeping it
to myself.  It certainly is not an example of inspired Programming.
But then, I thought, if everyone felt that way you'd have nothing to
chose from and even if this is not a prize winner, mayby someone
else will find it useful.

So here it is...  not extensively tested, but I couldn't find any
bugs.  Used Pretty to reFormat itself and it still Compiled and
worked.  Anyway, the only possible use is to another Turbo Pascal
Programmer who shouldn't have any difficult modifying to suit
himself.  They'd probably do that anyway since the output represents
my own peculiar notion as to what a readable Format should be.

'Pretty Printers' date back to the earliest Computer days and
Variations existed For just about any language.  However, I've been
unable to find a current one For Turbo Pascal.

Here's what this one does:

Pretty With no parameters generates a syntax message.

Input is scanned line-by-line, Word-by-Word and Byte-by-Byte.  Any
identifiers recognized as part of TP's language are replaced by
mixed Case (in a style which _I_ like).  Someone else can edit
Constants Borland1 through Borland5 and TP3.  (Why TP3 later.)  The
first one on a line is capitalized anyway.

A fallout of this is to use selected ones to determine indentation
in increments of 'IndentSpcs' which I arbitrarily set to 3.  Change
if you like. Indentation is incremented whenever one of the
'IndentIDs' appears and decremented With 'UnindentIDs' (surprise!).

Single indents are also provided For 'SectionIDs' (Const, Type,
Uses, Var) and For 'NestIDs' (Procedure Function) to make these more
visible.  White space is what does it, right?

On the other hand, no attempt is made to affect white space in the
vertical direction.  Since that generally stays the way you
originate it.

Any '{', '(' or '''' (Single quote) detected during the line scan
trigger a 'skipit' mode which moves the enclosed stuff directly to
output, unmodified. With one exception.  {Comments} which begin a
line are aligned to the left margin (where I like to see Compiler
directives and one line Procedure/Function explanations).  Other
{Comments} which begin/end on the same line are shifted so the '}'
aligns at the (80th column) right margin.  I think this makes them
more visible than when snuggled up to a semi-colon and getting them
away from the code makes it more legible, too.

and it did look better originally when it used some of my personal
Units. Hastily modified to stand alone.  There are, no doubt, some
obvious ways the Programming can be improved (you would probably
have used some nice hash tables to look up key Words) but, as I say,
I thought I would be the only one using this and speed in this Case
is not all that important.

With one exception.  Something I worked up For an earlier
application and may be worth looking at -- 'LowCase'.

It will Compile With TP4-TP5.5 and probably TP6 (if it still
supports Inline). I included TP3 stuff because some of the old
software I was looking at was written in it.  and it recognizes
Units in a clumsy sort of way.

Switching to chat mode here.  if you're Really busy, you can skip the
following.

This thing actually began as a 'Case-converter'.  I was trying to
avoid re-inventing some wheels by re-working some old Pascal source
dating back to the late 70's and 80's.  Upper Case Programs became a
'standard' back in the days when you talked to main frames through a
teleType machine, which has no lower Case.  Sadly, this persisted
long after it was no longer necessary and I find those
all-upper-Case Programs almost unreadable.  That is I can't find
what I'm looking For.  They were making me crazy.  (BTW I suspect
some of this has to do With why Pascal has UpCase but no LoCase.)

I stole the orginal LowCase included here from someone who had done
the intuitive thing -- first test For 'A', then For 'Z'.  Changing
to an initial test For 'Z' does two things.  A whopping 164 of the
255 possible Characters can be eliminated With just one test and,
since ordinary Text consists of mostly lower Case, these will be
passed over rapidly.

When you received this you thought, "Who the heck is Art Weller?  I
don't remember him on the Pascal Echo."  Right.  I'm a 'lurker'!
Been reading the echo since beFore it had a moderator.  (Now we have
an excellent one.  Thank you.) I have a machine on a timer which
calls the BBS each morning to read and store several echos which I
read later.  Rarely get inspired enough to call back and enter a
discussion.  Things usually get resolved nicely without me.  I
especially don't want to get involved in such as the 'Goto' wars.
But I monitor the better discussions to enhance my TP skills.

I'm not Really a Programmer (no Formal training, that is --
Computers hadn't been invented when I was in school!), but an
engineer.  I'm retired from White Sands Missile Range where I was
Chief of Plans and Programs For (mumble, mumble) years.  I
self-taught myself Computers when folks from our Analysis and
Computation Directorate started using jargon on me.  I did that well
enough to later help Write a book For people who wanted to convert
from BASIC to Pascal then after "retiring" was an editor For a small
Computer magazine (68 Micro-Journal).

In summary, if you think this worth sharing With others I'll be
pleased enough even without a prize.  not even sure it will get
there in time.  Snail-Mail, you know.
*)

Program Pretty;
{A 'Pretty Printer' For Turbo Pascal Programs}
{  This Program converts Turbo Pascal identifiers in a source code File to
   mixed Case and indents the code.
   Released into Public Domain June, 1992 on an 'AS IS' basis.  Enjoy at your
   own risk.
                                                    Art Weller
                                                    3217 Pagosa Court
                                                    El Paso, Texas  79904
                                                    U. S. A.
                                                    Ph. [phone]}

{Uses
   Strings;}

Const
   IndentSpcs = 3;

   Borland1 =
   ' Absolute Addr and ArcTan Array Assign AuxInptr AuxOutptr BDos begin Bios '+
   ' BlockRead BlockWrite Boolean Buflen Byte Case Chain Char Chr Close ClrEol '+
   ' ClrScr Color Concat Const Copy Cos Delay Delete DelLine Dispose div do ';
   Borland2 =
   ' Downto Draw else end Eof Eoln Erase Execute Exp External False File '+
   ' FilePos FileSize FillChar Flush For Forward Frac Freemem Function Getmem '+
   ' Goto GotoXY Halt HeapPtr Hi HighVideo HiRes if Implementation in Inline ';
   Borland3 =
   ' Input Insert InsLine Int Integer Interface Intr IOResult KeyPressed '+
   ' Label Length Ln Lo LowVideo Lst Mark MaxAvail Maxint Mem MemAvail Memw Mod '+
   ' Move New Nil NormVideo not Odd of Ofs or Ord Output Overlay Packed ';
   Borland4 =
   ' Pallette Pi Plot Port Pos Pred Procedure Program Ptr Random Randomize Read '+
   ' ReadLn Real Record Release Rename Repeat Reset ReWrite Round Seek Seg Set '+
   ' Shl Shr Sin SizeOf Sound Sqr Sqrt Str String Succ Swap Text then to ';
   Borland5 =
   ' True Trunc Type Unit Until UpCase Uses UsrOutPtr Val Var While Window With '+
   ' Write WriteLn xor ';
   TP3 =
   ' AUX CONinPTR CON CONOUTPTR ConstPTR CrtEXIT CrtinIT ERRorPTR Kbd '+
   ' LStoUTPTR TRM USR USRinPTR ';

   IndentIDs   = ' begin Case Const Record Repeat Type Uses Var ';
   UnIndentIDs = ' end Until ';
   SectionIDs  = ' Const Type Uses Var ';
   endSection  = ' begin Const Uses Var Function Implementation Interface '+
                 ' Procedure Type Unit ';
   NestIDs     = ' Function Procedure Unit ';

   IDAlphas    = ['a'..'z', '1'..'0', '_'];

Var
   Indent,
   endPend,
   Pending,
   UnitFlag       : Boolean;
   NestLevel,
   NestIndent,
   IndentNext,
   IndentNow,
   Pntr, LineNum  : Integer;
   IDs,
   InFile,
   OutFile,
   ProgWrd,
   ProgLine       : String;
   Idents,
   OutID          : Array [1..5] of String;
   f1, f2         : Text;

Function  LowCase(Ch: Char): Char;
begin
  Inline(
   $8A/$86/>Ch/                          {      mov al,>Ch[bp]   ;Char to check}
   $3C/$5A/                              {      cmp al,'Z'                     }
   $7F/$06/                              {      jg  Done                       }
   $3C/$41/                              {      cmp al,'A'                     }
   $7C/$02/                              {      jl  Done                       }
   $0C/$20/                              {      or al,$20                      }
   $88/$86/>LowCase);                    {Done :mov >LowCase[bp],al            }
end;

Function LowCaseStr(InStr : String): String;
Var
  i  : Integer;
  len: Byte Absolute InStr;
begin
  LowCaseStr[0] := Chr(len);
  For i := 1 to len do
  LowCaseStr[i] := LowCase(InStr[i]);
end;

Function  Blanks(Count: Byte): String; {return String of 'Count' spaces}
Var
  Result: String;
begin
  FillChar(Result[1], Count+1, ' ');
  Result[0] := Chr(Count);
  Blanks := Result;
end;

Procedure StripLeading(Var Str: String);  {remove all leading spaces}
begin
  While (Str[1] = #32) and (length(Str) > 0) do
    Delete(Str,1,1);
end;

Procedure Initialize;
begin
  IDs := IndentIDs + UnIndentIDs + endSection;
  OutID[1] := Borland1;
  Idents[1] := LowCaseStr(OutID[1]);
  OutID[2] := Borland2;
  Idents[2] := LowCaseStr(OutID[2]);
  OutID[3] := Borland3;
  Idents[3] := LowCaseStr(OutID[3]);
  OutID[4] := Borland4;
  Idents[4] := LowCaseStr(OutID[4]);
  OutID[5] := Borland5 + TP3;
  Idents[5] := LowCaseStr(OutID[5]);
  Pending := False;
  UnitFlag := False;
  IndentNext := 0;
  IndentNow := 0;
  LineNum := 0;
  NestIndent := 0;
  NestLevel := 0;
end;

Procedure Greeting;
begin
  Writeln;
  Writeln('Pascal Program Indenter');
  Writeln; Writeln;
  Writeln('SYNTAX:  INDENT InputFile OutPutFile');
  Writeln('         INDENT InputFile > OutPut');
  Writeln; Writeln;
  Halt(0);
end;

Procedure OpenFiles;
begin
  if paramcount <> 0 then
  begin
    InFile := ParamStr(1);
    if (pos('.', InFile) = 0) then
      InFile := InFile + '.pas';
    OutFile := Paramstr(2);
  end
  else
    Greeting;
  Assign(f1, InFile);
  Reset(f1);
  Assign(f2, OutFile);
  ReWrite(f2);
end;

Procedure GetWord;
Var
  i,
  index,
  TmpPtr,
  WrdPos   : Integer;

  Procedure DecIndent;
  begin
    if (IndentNext > IndentNow) then   {begin/end on same line}
      Dec(IndentNext)
    else
    if IndentNow > 0 then
      dec(IndentNow);
    IndentNext := IndentNow;    {next line, too}
  end;

begin
  ProgWrd := ' ';
  TmpPtr := Pntr;

  While (LowCase(ProgLine[Pntr]) in IDAlphas) {Convert checked For LCase alpha}
        and (Pntr <= length(ProgLine)) do
  begin
    ProgWrd := ProgWrd + LowCase(ProgLine[Pntr]);
    Inc(Pntr);
  end;

  ProgWrd := ProgWrd+' ';   {surrounded With blanks to make it unique!}
  index := 0;

  Repeat;     {is it a Turbo Pascal Word?}
    inc(index);
    WrdPos := Pos(ProgWrd, Idents[index]);
  Until (WrdPos <> 0) or (index = 5);

  if WrdPos <> 0 then   {found a Pascal Word}
  begin
    Move(OutID[index][WrdPos+1], ProgLine[TmpPtr], Length(ProgWrd)-2);
    if TmpPtr = 1 then
      ProgLine[1] := UpCase(ProgLine[1]);

    if Pos(ProgWrd, IDs) <> 0 then  {only checked if a Pascal Word ^}
    begin
      if Pos(ProgWrd, endSection) <> 0 then  {this includes "SectionIDs"}
      begin                                      {and "NestIDs"}
        if (pos(ProgWrd, NestIDs) <> 0) then
        begin
          if ProgWrd = ' Unit ' then
            UnitFlag := True;
          if not UnitFlag then
            inc(NestLevel);
        end;
        if Pending then
          DecIndent;
        Pending := Pos(ProgWrd, SectionIDs) <> 0;
        if ProgWrd = ' Implementation ' then
          UnitFlag := False;
      end;
      if Pos(ProgWrd, IndentIDs) <> 0 then
        inc(IndentNext); {Indent 1 level}
      if Pos(ProgWrd, UnIndentIDs) <> 0 then
      begin
         DecIndent;   {Unindent 1 level}
         if (IndentNow = 0) and (NestLevel > 0) then
           dec(NestLevel);
      end;
      if NestLevel > 1 then
        NestIndent := 1;
    end;
  end;
end;

Procedure Convert;

  Procedure OutLine;
  Var
    Tabs : String[40];
  begin
    Tabs := Blanks((IndentNow+NestIndent) * IndentSpcs);
    if ProgLine[1] = '{' then
      Writeln(f2, ProgLine)
    else
      Writeln(f2, Tabs, ProgLine);
    IndentNow := IndentNext;   { get ready For next line }
    if NestLevel < 2 then
      NestIndent := 0;
  end;

  Procedure Skipto(SearchChar: Char);
  begin
    Repeat
      if pntr > Length(ProgLine) then
      begin
        OutLine;
        Readln(f1, ProgLine);   {get another line}
        Pntr := 0;
      end;
      Inc(pntr);
    Until (ProgLine[pntr] = SearchChar) or Eof(f1);
  end;

  Procedure MoveComments;
  Var
    TmpIndent : Integer;
  begin
    if (ProgLine[1] = '{') or (ProgLine[Pntr+1] = '$') then
    begin
      Skipto('}');
      Exit;
    end;
    TmpIndent := (IndentNow+NestIndent) * IndentSpcs;
    While Length(ProgLine) < 80-TmpIndent do
      Insert(' ', ProgLine, Pntr);
    While (pos('}', ProgLine) > 80-TmpIndent) and (pos(' {', ProgLine) > 1) do
    begin
      Delete(ProgLine, Pos(' {', ProgLine), 1);
      Dec(Pntr);
    end;
    Skipto('}');
  end;

begin
  While not Eof(f1) do
  begin
    Readln(f1, ProgLine);
    StripLeading(ProgLine);
    if Length(ProgLine) = 0 then
      Writeln(f2)
    else
    begin
      Pntr := 1;
      Repeat
        Case LowCase(ProgLine[pntr]) of
          'a'..'z','_'  :  GetWord;
          '{'           :  MoveComments;
          '('           :  Skipto(')');
          #39           :  Skipto(#39)        {Single quote}
        end;
        Inc(pntr)
      Until (pntr >= length(ProgLine));
      OutLine;
    end;
  end;  { While }
  Close(f1); Close(f2);
end;

begin
  Initialize;
  OpenFiles;
  Convert;
end.